home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
thomas
/
thomas.lha
/
Thomas
/
Thomas-1.1
/
src
/
runtime-collections-array.scm
< prev
next >
Wrap
Text File
|
1992-09-08
|
12KB
|
335 lines
;* Copyright 1992 Digital Equipment Corporation
;* All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions. Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software. Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software. Correspondence should be provided to Digital at:
;*
;* Director, Cambridge Research Lab
;* Digital Equipment Corp
;* One Kendall Square, Bldg 700
;* Cambridge MA 02139
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.
; $Id: runtime-collections-array.scm,v 1.17 1992/09/08 11:15:05 birkholz Exp $
;;;;; RUNTIME-COLLECTIONS-ARRAY.SCM
;;;;; This file contains all the specializations for array type
(add-method dylan:shallow-copy
(dylan::function->method
(make-param-list `((ARRAY ,<array>)) #F #F #F)
(lambda (array)
(let* ((dimensions (dylan-call dylan:dimensions array))
(new-array
(dylan-call dylan:make <array> 'dimensions: dimensions))
(key-sequence (dylan-call dylan:key-sequence array)))
(do ((state (dylan-call dylan:initial-state key-sequence)
(dylan-call dylan:next-state key-sequence state)))
((not state)
(dylan-call dylan:as
(dylan-call dylan:class-for-copy array)
new-array))
(let ((key (dylan-call dylan:current-element key-sequence state)))
(dylan-call dylan:setter/element/
new-array
key
(dylan-call dylan:element array key))))))))
(add-method dylan:as
(dylan::function->method
(make-param-list `((CLASS ,(dylan::make-singleton <array>))
(COLLECTION ,<collection>)) #F #F #F)
(lambda (class collection)
class
(if (dylan-call dylan:instance? collection <array>)
collection
(let* ((size (dylan-call dylan:size collection))
(new-array
(dylan-call dylan:make <array> 'dimensions: (list size)))
(vector-value (dylan-call dylan:get-array-value new-array)))
(do ((state (dylan-call dylan:initial-state collection)
(dylan-call dylan:next-state collection state))
(index 0 (+ index 1)))
((not state) new-array)
(vector-set! vector-value index
(dylan-call
dylan:current-element collection state))))))))
;;;
;;; ARRAY SPECIALIZED MAKE
;;;
;; All subclasses of ARRAY have slots for the data ("value") and a
;; list of dimensions ("dimensions").
(define dylan:get-array-value "define dylan:get-array-value")
(define dylan:get-array-dimensions "define dylan:get-array-dimensions")
(define dylan:set-array-value! "define dylan:set-array-value!")
(define dylan:set-array-dimensions! "define dylan:set-array-dimensions!")
(create-private-slot <array> <simple-object-vector>
"internal-array-value"
(lambda (set get)
(set! dylan:set-array-value! set)
(set! dylan:get-array-value get)))
(create-private-slot <array> <list>
"internal-array-dimensions"
(lambda (set get)
(set! dylan:set-array-dimensions! set)
(set! dylan:get-array-dimensions get)))
;; These four generic operations must be specialized for the special
;; cases of <byte-string> and <simple-object-vector>
(add-method dylan:get-array-value
(one-arg 'STRING <byte-string> (lambda (string) string)))
(add-method dylan:set-array-value!
(dylan::function->method
(make-param-list `((STRING ,<byte-string>) (VALUE ,<object>)) #F #F #F)
(lambda (string value)
(dylan-call dylan:error
"set-array-value! -- internal error on string"
string value))))
(add-method dylan:get-array-dimensions
(one-arg 'STRING <byte-string>
(lambda (string) (list (string-length string)))))
(add-method dylan:set-array-dimensions!
(dylan::function->method
(make-param-list `((STRING ,<byte-string>) (VALUE ,<object>)) #F #F #F)
(lambda (string value)
(dylan-call dylan:error
"set-array-dimensions! -- internal error on string"
string value))))
(add-method dylan:get-array-value
(one-arg 'VECTOR <simple-object-vector>
(lambda (vector) vector)))
(add-method dylan:set-array-value!
(dylan::function->method
(make-param-list `((VECTOR ,<simple-object-vector>)
(VALUE ,<object>)) #F #F #F)
(lambda (vector value)
(dylan-call dylan:error
"set-array-value! -- internal error on simple-object-vector"
vector value))))
(add-method dylan:get-array-dimensions
(one-arg 'VECTOR <simple-object-vector>
(lambda (vector) (list (vector-length vector)))))
(add-method dylan:set-array-dimensions!
(dylan::function->method
(make-param-list `((VECTOR ,<simple-object-vector>)
(VALUE ,<object>)) #F #F #F)
(lambda (vector value)
(dylan-call
dylan:error
"set-array-dimensions! -- internal error on simple-object-vector"
vector value))))
(add-method
dylan:make
(dylan::dylan-callable->method
(make-param-list `((ARRAY ,(dylan::make-singleton <array>)))
#F #F '(dimensions: fill:))
(lambda (multiple-values next-method class . rest)
(define (make-multi-dimensional-array dimensions fill)
(if (null? dimensions)
(dylan-call dylan:error
"make -- 0-dimensional arrays not allowed"))
(let ((result (make-vector (car dimensions) fill)))
(if (null? (cdr dimensions))
result
(do ((n 0 (+ n 1)))
((= n (car dimensions)) result)
(vector-set! result n
(make-multi-dimensional-array
(cdr dimensions)
fill))))))
multiple-values ; Ignored
class ; Ignored
(dylan::keyword-validate next-method rest '(dimensions: fill:))
(let ((dimensions
(dylan::find-keyword rest 'dimensions:
(lambda ()
(dylan-call dylan:error
"make -- array needs dimensions"
class rest))))
(fill-value (dylan::find-keyword rest 'fill: (lambda () #F))))
(if (not (subclass? (get-type dimensions) <sequence>))
(dylan-call dylan:error
"make -- array dimensions not a sequence"
class dimensions))
(let ((instance (dylan::make-<object> <array>))
(dim-list
(iterate->list
(lambda (elem)
(if (not (and (integer? elem)
(positive? elem)))
(dylan-call
dylan:error
"make -- dimension elements not all positive integers"
class dimensions elem)
elem))
dimensions)))
(dylan-call dylan:set-array-value!
instance
(make-multi-dimensional-array dim-list fill-value))
(dylan-call dylan:set-array-dimensions! instance dim-list)
instance)))))
;;;;
;;;; Operations on Arrays (page 113 )
;;;;
(define dylan:aref
(dylan::generic-fn 'aref
(make-param-list `((ARRAY ,<array>)) #F #T #F)
(lambda (array-instance . init-indices)
(if (null? init-indices)
(dylan-call dylan:error
"aref -- no indices given" array-instance))
(let loop ((array (dylan-call dylan:get-array-value array-instance))
(indices init-indices))
(if (vector? array)
(let ((size (vector-length array))
(index (car indices)))
(if (>= index size)
(dylan-call dylan:error
"aref -- subscript out of range"
array-instance init-indices array index))
(if (null? (cdr indices))
(vector-ref array index)
(loop (vector-ref array index) (cdr indices))))
(dylan-call dylan:error
"aref -- too many subscripts"
array-instance init-indices indices))))))
(define dylan:setter/aref/
(dylan::generic-fn 'aref
(make-param-list `((ARRAY ,<array>)) #F #T #F)
(lambda (array-instance . indices-and-new-value)
(if (null? indices-and-new-value)
(dylan-call dylan:error
"(setter aref) -- no indices and new-value given"
array-instance))
(let ((new-value (list-ref indices-and-new-value
(- (length indices-and-new-value) 1)))
(indices (but-last indices-and-new-value)))
(if (not (pair? indices))
(dylan-call dylan:error
"(setter aref) -- no indices given"
array-instance indices-and-new-value))
(let loop ((array (dylan-call dylan:get-array-value array-instance))
(indices indices))
(if (vector? array)
(let ((size (vector-length array))
(index (car indices)))
(if (>= index size)
(dylan-call dylan:error
"(setter aref) -- subscript out of range"
array-instance indices-and-new-value
array index))
(if (null? (cdr indices))
(if (vector? (vector-ref array index))
(dylan-call
dylan:error
"(setter aref) -- indices need to point to an element"
array-instance indices-and-new-value array index)
(begin
(vector-set! array index new-value)
new-value))
(loop (vector-ref array index) (cdr indices))))
(dylan-call dylan:error
"(setter aref) -- too many subscripts"
array-instance indices-and-new-value indices)))))))
(define dylan:dimensions
(dylan::generic-fn 'dimensions
(make-param-list `((ARRAY ,<array>)) #F #F #F)
(lambda (array)
(dylan-call dylan:get-array-dimensions array))))
(add-method
dylan:element
(dylan::dylan-callable->method
(make-param-list `((ARRAY ,<array>) (INDEX ,<sequence>)) #F #F '(default:))
(lambda (multiple-values next-method array-instance init-indices . rest)
multiple-values
(dylan::keyword-validate next-method rest '(default:))
(let* ((default (dylan::find-keyword rest 'default: (lambda () #F)))
(error-report (lambda args (if default
default
(apply dylan:error args)))))
(if (dylan-call dylan:empty? init-indices)
(error-report "element -- no indices given" array-instance)
(let loop ((array
(dylan-call dylan:get-array-value array-instance))
(index-state
(dylan-call dylan:initial-state init-indices)))
(let ((index (dylan-call dylan:current-element
init-indices index-state)))
(if (vector? array)
(cond ((>= index (vector-length array))
(error-report "element -- subscript out of range"
array-instance init-indices array index))
((not
(dylan-call dylan:next-state
init-indices index-state))
(vector-ref array index))
(else (loop (vector-ref array index)
(dylan-call dylan:next-state
init-indices index-state))))
(error-report "element -- too many subscripts"
array-instance init-indices index)))))))))
(add-method dylan:current-key
(dylan::function->method
(make-param-list `((ARRAY ,<array>) (STATE ,<object>)) #F #F #F)
(lambda (array state)
array ; Ignored
state)))
;;;
;;; Mutable Collections
;;;
(add-method dylan:setter/current-element/
(dylan::function->method
(make-param-list
`((ARRAY ,<array>) (STATE ,<object>) (new-value ,<object>)) #F #F #F)
(lambda (array state new-value)
array ; Ignored
(let loop ((vectors (dylan-call dylan:get-array-value array))
(state (vector->list state)))
(if (= (length state) 1)
(begin
(vector-set! vectors (car state) new-value)
new-value)
(loop (vector-ref vectors (car state))
(cdr state)))))))